home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / COMPNENT / ISAMEXPT / CALPOP.PAS < prev    next >
Pascal/Delphi Source File  |  1996-04-04  |  30KB  |  906 lines
  1. unit Calpop;
  2.  
  3. (*********************************************
  4. This form unit is used by the DateEdit component.
  5. *********************************************)
  6.  
  7. interface
  8.  
  9. uses
  10.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  11.   Forms, Dialogs, Buttons, StdCtrls;
  12.  
  13. const
  14.    m_DaysPerMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  15.    m_DayTitles : Array[0..6] of string[2] = ('So','Mo','Di','Mi','Do','Fr','Sa');
  16.    BORDER = 2;
  17.    TEXT_INDENT = 2;
  18.    BUTTON_WIDTH = 16;
  19.  
  20. type
  21.   {////  Calendar Form Type Definition /////}
  22.   TfrmCalPop = class( TForm )
  23.     procedure FormCancel;
  24.     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
  25.       Shift: TShiftState; X, Y: Integer);
  26.     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
  27.       Shift: TShiftState; X, Y: Integer);
  28.     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  29.       Y: Integer);
  30.     procedure FormKeyDown(Sender: TObject; var Key: Word;
  31.       Shift: TShiftState);
  32.     procedure FormPaint(Sender: TObject);
  33.   private
  34.     m_CurrentDateSelected: TDateTime;
  35.     m_FontWidth : Integer;
  36.     m_FontHeight : Integer;
  37.     m_DateArray : array[1..42] of string[2];
  38.     m_CurrentDateIndex : Integer;
  39.     m_PreviousDateIndex : Integer;
  40.     m_PreviousDateRect : TRect;
  41.     m_MouseDown : BOOL;
  42.     m_CurrentDay, m_CurrentYear, m_CurrentMonth : Word;
  43.     m_PreviousDay, m_PreviousYear, m_PreviousMonth : Word;
  44.     ctlParent: TComponent;
  45.   protected
  46.     function DaysInMonth(nMonth : Integer): Integer;
  47.     procedure DrawButtons;
  48.     procedure DrawCalendarBorder;
  49.     procedure DrawDates;
  50.     procedure DrawDaysHeader;
  51.     procedure DrawFocusFrame(nIndex : Integer);
  52.     procedure DrawMonthHeader;
  53.     function GetMonthBegin: Integer;
  54.     function GetCalendarRect : TRect;
  55.     function GetLeftButtonRect : TRect;
  56.     function GetRightButtonRect : TRect;
  57.     function GetRectFromIndex(nIndex : Integer): TRect;
  58.     function GetIndexFromDate : Integer;
  59.     function GetIndexFromPoint(nLeft : Integer ; nTop : Integer) : Integer;
  60.     function IsLeapYear: Boolean;
  61.     procedure LoadDateArray ;
  62.     procedure NextDay;
  63.     procedure PrevDay;
  64.     procedure NextWeek;
  65.     procedure PrevWeek;
  66.     procedure NextMonth;
  67.     procedure PrevMonth;
  68.     procedure NextYear;
  69.     procedure PrevYear;
  70.     procedure SetDate(nDays : Integer);
  71.   public
  72.     constructor Create( AOwner: TComponent ); override;
  73.   end;
  74.  
  75. var
  76.   frmCalPop: TfrmCalPop;
  77.  
  78. implementation
  79.  
  80. {$R *.DFM}
  81.  
  82. uses
  83.   DateEdit;
  84.  
  85. function PointInRect( const rectTest: TRect; X, Y: integer ): boolean;
  86. begin
  87.   Result := ( ( X >= rectTest.Left ) and ( X <= rectTest.Right ) and
  88.      ( Y >= rectTest.Top ) and ( Y <= rectTest.Bottom ) );
  89. end;
  90.  
  91. {************************** Create ************************
  92.  *****  This procedure is used to initialize values   *****
  93.  *****  for control owner, calendar position and      *****
  94.  *****  other resources.                              *****
  95.  **********************************************************}
  96. constructor TfrmCalPop.Create(AOwner: TComponent);
  97. var
  98.    tmTextMetrics : TTextMetric;
  99.    editOwner: TEdit;
  100.    rectPlace: TRect;
  101.    ptUpper, ptLower: TPoint;
  102. begin
  103.   inherited Create(AOwner);
  104.  
  105.   {If the FontWidth is not set, determine Font Height and Width for positioning Dates}
  106.   with Canvas do
  107.      begin
  108.         Font.Name := 'MS Sans Serif';
  109.         Font.Size := 6;
  110.         Pen.Color := clBlack;
  111.         GetTextMetrics(Handle, tmTextMetrics);
  112.         m_FontWidth :=  Round(tmTextMetrics.tmAveCharWidth + tmTextMetrics.tmAveCharWidth * 6 / 10);
  113.         m_FontHeight :=  Round(tmTextMetrics.tmHeight + tmTextMetrics.tmHeight / 3);
  114.      end;
  115.  
  116.   {Initialize form Height & Width based on Font }
  117.   Height := (m_FontHeight * 6) + (m_FontHeight * 2) + BORDER;
  118.   Width := ((m_FontWidth *3) * 7) + (2* BORDER) + (2* TEXT_INDENT);
  119.  
  120. { Dynamically set the size and position }
  121.   editOwner := TDateEdit( AOwner );
  122.   ctlParent := editOwner;
  123.   rectPlace := editOwner.ClientRect;
  124.   ptUpper.X := rectPlace.Left;
  125.   ptUpper.Y := rectPlace.Top;
  126.   ptUpper := editOwner.ClientToScreen( ptUpper );
  127.   ptLower.X := rectPlace.Right;
  128.   ptLower.Y := rectPlace.Bottom;
  129.   ptLower := editOwner.ClientToScreen( ptLower );
  130.  
  131.   { If too far down, pop the calendar above the control }
  132.   if ptUpper.X + 1 + Width > Screen.Width then
  133.      Left := Screen.Width - Width - 1
  134.   else
  135.      Left := ptUpper.X + 1;
  136.   if ptLower.Y + 1 + Height > Screen.Height then
  137.      Top := ptUpper.Y - Height
  138.   else
  139.      Top := ptLower.Y + 1;
  140.  
  141.   { define initial date }
  142.   if TDateEdit( ctlParent ).Text <> '' then
  143.      m_CurrentDateSelected := StrToDate( TDateEdit( ctlParent ).Text )
  144.   else
  145.      m_CurrentDateSelected := Date;
  146.  
  147.   {Extract date Components}
  148.   DecodeDate( m_CurrentDateSelected, m_CurrentYear, m_CurrentMonth, m_CurrentDay );
  149.   m_CurrentDateIndex := m_CurrentDay + GetMonthBegin - 1;
  150.   m_PreviousDateIndex := 0;
  151.  
  152.   LoadDateArray;
  153.   m_MouseDown := False;
  154. end;
  155.  
  156.  
  157. {********************** Days In Month *********************
  158.  *****  This function returns the number of days in   *****
  159.  *****  the month specified in nMonth.                *****
  160.  **********************************************************}
  161. function TfrmCalPop.DaysInMonth(nMonth : Integer): Integer;
  162. begin
  163.   Result := m_DaysPerMonth[nMonth];
  164.   if ( nMonth = 2 ) and IsLeapYear then Inc( Result ); { leap-year Feb is special }
  165. end;
  166.  
  167.  
  168. {******************** Draw Butttons ***********************
  169.  **********************************************************}
  170. procedure TfrmCalPop.DrawButtons;
  171. var
  172.   LeftButtonRect: TRect;
  173.   RightButtonRect : TRect;
  174.   OldStyle : TBrushStyle;
  175. begin
  176.   with Canvas do
  177.      begin
  178.         LeftButtonRect := GetLeftButtonRect;
  179.         RightButtonRect := GetRightButtonRect;
  180.  
  181.         { Select Black Pen}
  182.         Pen.Style := psSolid;
  183.         Pen.Width := 1;
  184.         Pen.Color := clBlack;
  185.  
  186.         { Draw Button Outlines }
  187.         Rectangle( LeftButtonRect.Left, LeftButtonRect.Top, LeftButtonRect.Right, LeftButtonRect.Bottom );
  188.         Rectangle( RightButtonRect.Left, RightButtonRect.Top, RightButtonRect.Right, RightButtonRect.Bottom );
  189.  
  190.         { Create Embossed effect - Outline left & upper in white}
  191.         Pen.Color := clWhite;
  192.         MoveTo( LeftButtonRect.Left + 1, LeftButtonRect.Bottom - 2 );
  193.         LineTo( LeftButtonRect.Left + 1, LeftButtonRect.Top + 1 );
  194.         LineTo( LeftButtonRect.Right - 2, LeftButtonRect.Top + 1 );
  195.  
  196.         MoveTo( RightButtonRect.Left + 1, RightButtonRect.Bottom - 2 );
  197.         LineTo( RightButtonRect.Left + 1, RightButtonRect.Top + 1 );
  198.         LineTo( RightButtonRect.Right - 2, RightButtonRect.Top + 1 );
  199.  
  200.         { Create Embossed effect - Outline right & bottom in gray }
  201.         Pen.Color := clGray;
  202.         MoveTo( LeftButtonRect.Right -2, LeftButtonRect.Top +  1 );
  203.         LineTo( LeftButtonRect.Right - 2, LeftButtonRect.Bottom - 2 );
  204.         LineTo( LeftButtonRect.Left + 1, LeftButtonRect.Bottom - 2 );
  205.  
  206.         MoveTo( RightButtonRect.Right - 2, RightButtonRect.Top + 1 );
  207.         LineTo( RightButtonRect.Right - 2, RightButtonRect.Bottom - 2 );
  208.         LineTo( RightButtonRect.Left + 1, RightButtonRect.Bottom - 2 );
  209.  
  210.         {Draw Arrow}
  211.         Brush.Color := clBlack;
  212.         OldStyle :=Brush.Style;
  213.         Brush.Style := bsSolid;
  214.         Polygon([Point(LeftButtonRect.Right - 5,LeftButtonRect.Top + 3),
  215.                  Point(LeftButtonRect.Right - 5,LeftButtonRect.Bottom - 4),
  216.                  Point(LeftButtonRect.Left + 3,LeftButtonRect.Top + 7)]);
  217.         Polygon([Point(RightButtonRect.Left + 4,RightButtonRect.Top + 3),
  218.                  Point(RightButtonRect.Left + 4,RightButtonRect.Bottom - 4),
  219.                  Point(RightButtonRect.Right - 4,RightButtonRect.Top + 7)]);
  220.         Brush.Color :=clSilver;
  221.         Brush.Style := OldStyle;
  222.         Pen.Color := clBlack;
  223.      end;
  224. end;
  225.  
  226. {*************** Draw Calendar Border *********************
  227.  **********************************************************}
  228. procedure TfrmCalPop.DrawCalendarBorder;
  229. var
  230.   rectDraw: TRect;
  231. begin
  232.   rectDraw := ClientRect;
  233.   with Canvas do
  234.      begin
  235.         { Select Black Pen to outline Window }
  236.         Pen.Style := psSolid;
  237.         Pen.Width := 1;
  238.         Pen.Color := clBlack;
  239.  
  240.         { Outline the window in black }
  241.         Rectangle( rectDraw.Left, rectDraw.Top, rectDraw.Right, rectDraw.Bottom );
  242.  
  243.         { Create Embossed effect - Outline left & upper in white}
  244.         Pen.Color := clWhite;
  245.         MoveTo( 0, rectDraw.Bottom - 1 );
  246.         LineTo( 0, 0 );
  247.         LineTo( rectDraw.Right - 1, 0 );
  248.  
  249.         { Create Embossed effect - Outline right & bottom in gray }
  250.         Pen.Color := clGray;
  251.         LineTo( rectDraw.Right - 1, rectDraw.Bottom - 1 );
  252.         LineTo( 0, rectDraw.Bottom - 1 );
  253.  
  254.         { Reset Pen Color }
  255.         Pen.Color := clBlack;
  256.      end;
  257. end;
  258.  
  259. {*********************** Draw Dates ***********************
  260.  **********************************************************}
  261. procedure TfrmCalPop.DrawDates;
  262. var
  263.    nIndex, nWeek, nDay: Integer;
  264.    pDate: PChar;
  265.    TempRect: Trect;
  266.    dtTest: TDateTime;
  267. begin
  268.   pDate := StrAlloc( 3 );
  269.  
  270.   With Canvas do
  271.      begin
  272.         { Define normal font }
  273.         Font.Style := [];
  274.         Pen.Color := clBlack;
  275.  
  276.         { Cycle through the weeks }
  277.         for nWeek := 1 to 6 do
  278.            begin
  279.               { Cycle through the days }
  280.               for nDay := 1 to 7 Do
  281.                  begin
  282.                     nIndex := nDay + ( ( nWeek - 1 ) * 7 );
  283.                     StrPCopy( pDate, m_DateArray[nIndex] );
  284.                     if m_DateArray[nIndex] <> '  ' then
  285.                        begin
  286.                           dtTest := EncodeDate( m_CurrentYear, m_CurrentMonth, StrToInt( m_DateArray[nIndex] ) );
  287.                           if ( ctlParent as TDateEdit ).DateInList( dtTest ) then
  288.                              Font.Color := ( ctlParent as TDateEdit ).ValidDateColor
  289.                           else
  290.                              Font.Color := clBlack;
  291.                        end;
  292.                     TempRect := GetCalendarRect;
  293.  
  294.                     With TempRect Do
  295.                     begin
  296.                        Left := Left + ((m_FontWidth * 3) * (nDay - 1));
  297.                        Top := (m_FontHeight * nWeek ) + m_FontHeight + Border;
  298.                        Bottom := Top +  m_FontHeight ;
  299.                        Right := Left + m_fontWidth * 3;
  300.                     end;
  301.  
  302.                     DrawText( Handle, pDate, Length( m_DateArray[nIndex] ),
  303.                               TempRect, ( DT_CENTER or DT_VCENTER or DT_TOP or DT_SINGLELINE ) );
  304.  
  305.                  end;
  306.                  nIndex := nIndex;
  307.            end;
  308.      end;
  309.      StrDispose( pDate );
  310. end;
  311.  
  312. {*********************** Draw Days ************************
  313.  **********************************************************}
  314. procedure TfrmCalPop.DrawDaysHeader;
  315. var
  316.    i: Integer;
  317.    pDay: PChar;
  318.    TempRect: Trect;
  319. begin
  320.   pDay := StrAlloc( 3 );
  321.  
  322.   { Calculate Rect Top.  2nd line = FontHeight * 2 }
  323.   TempRect := ClientRect;
  324.   TempRect.Top := m_FontHeight + BORDER;
  325.   TempRect.Bottom := TempRect.Top + m_FontHeight;
  326.  
  327.   {Calculate each date rect. rect = FontWidth * 3 (width of two chars + space) }
  328.   TempRect.Left := TempRect.Left + BORDER + TEXT_INDENT;
  329.   TempRect.Right := BORDER + TEXT_INDENT + ( m_FontWidth * 3 );
  330.  
  331.   { Cycle through the days }
  332.   for i := 0 to 6 do
  333.      begin
  334.         StrPCopy( pDay, m_DayTitles[i] );
  335.         DrawText( Canvas.Handle, pDay, 2, TempRect,
  336.                 ( DT_CENTER or DT_TOP or DT_SINGLELINE ) );
  337.         TempRect.Left := TempRect.Right;
  338.         TempRect.Right := TempRect.Right + m_FontWidth * 3;
  339.      end;
  340.  
  341.      { Draw line below days }
  342.      with Canvas do
  343.         begin
  344.            TempRect.Top := TempRect.Bottom - 3;
  345.            TempRect.Bottom := TempRect.Top + 2;
  346.            TempRect.Left := ClientRect.Left + BORDER + TEXT_INDENT;
  347.            TempRect.Right := BORDER + TEXT_INDENT + ( m_FontWidth * 3 * 7 );
  348.  
  349.            Pen.Color := clGray;
  350.            MoveTo( TempRect.Left , TempRect.Top);
  351.            LineTo( TempRect.Right, TempRect.Top );
  352.            Pen.Color := clWhite;
  353.            MoveTo( TempRect.Left,  TempRect.Top + 1 );
  354.            LineTo( TempRect.Right, TempRect.Top + 1  );
  355.         end;
  356.  
  357.      StrDispose( pDay );
  358. end;
  359.  
  360. {******************** Draw Month Header *******************
  361.  **********************************************************}
  362. procedure TfrmCalPop.DrawMonthHeader;
  363. var
  364.    sMonth : String;
  365.    pMonth : PChar;
  366.    TempRect : Trect;
  367. begin
  368.   pMonth := StrAlloc( 30 );
  369.   with Canvas do
  370.      begin
  371.         Font.Style := [fsBold];
  372.         Font.Color := clBlack;
  373.         sMonth := FormatDateTime( 'dd. mmmm yyyy', m_CurrentDateSelected );
  374.  
  375.         pMonth := StrAlloc( Length( sMonth ) + 1 );
  376.         StrPCopy( pMonth, sMonth );
  377.  
  378.         TempRect := ClientRect;
  379.         TempRect.Top := BORDER;
  380.         TempRect.Left := BORDER + TEXT_INDENT + BUTTON_WIDTH;
  381.         TempRect.Right := TempRect.Right - BORDER - TEXT_INDENT - BUTTON_WIDTH;
  382.         TempRect.Bottom := m_FontHeight;
  383.  
  384.         Brush.Color := clSilver;
  385.         Brush.Style := bsSolid;
  386.         FillRect( TempRect );
  387.  
  388.         DrawText( Handle, pMonth, Length( sMonth ), TempRect,
  389.                 ( DT_CENTER or DT_VCENTER or DT_BOTTOM or DT_SINGLELINE ) );
  390.      end;
  391.      StrDispose( pMonth );
  392. end;
  393.  
  394. {******************** Draw Focus Frame ********************
  395.  **********************************************************}
  396. procedure TfrmCalPop.DrawFocusFrame( nIndex: Integer);
  397. var
  398.   pDate :PChar;
  399.   TempRect : TRect;
  400.   dtTest: TDateTime;
  401. begin
  402.   pDate := StrAlloc( 3 );
  403.   If ( nIndex > 0 ) and ( nIndex < 42 ) then
  404.      If m_DateArray[nIndex] <> '  ' then
  405.         begin
  406.            { Erase Previous Date Focus}
  407.            If m_PreviousDateIndex > 0 Then
  408.               begin
  409.                  Canvas.Font.Style := [];
  410.                  StrPCopy( pDate, m_DateArray[m_PreviousDateIndex] );
  411.                  Canvas.Brush.Color := clSilver;
  412.                  TempRect := GetRectFromIndex(m_PreviousDateIndex);
  413.                  Canvas.FillRect(TempRect);
  414.                  DrawText( Canvas.Handle, pDate, Length( m_DateArray[m_PreviousDateIndex] ),
  415.                            TempRect, ( DT_CENTER or DT_VCENTER or DT_TOP or DT_SINGLELINE ) );
  416.               end;
  417.  
  418.            {Draw the Date in Bold font}
  419.            Canvas.Font.Style := [fsBold];
  420.            dtTest := EncodeDate( m_CurrentYear, m_CurrentMonth, StrToInt( m_DateArray[nIndex] ) );
  421.            if ( ctlParent as TDateEdit ).DateInList( dtTest ) then
  422.               Canvas.Font.Color := ( ctlParent as TDateEdit ).ValidDateColor
  423.            else
  424.               Canvas.Font.Color := clBlack;
  425.            TempRect := GetRectFromIndex(nIndex);
  426.            StrPCopy( pDate, m_DateArray[nIndex] );
  427.            DrawText( Canvas.Handle, pDate, Length( m_DateArray[nIndex] ),
  428.                      TempRect, ( DT_CENTER or DT_VCENTER or DT_TOP or DT_SINGLELINE ) );
  429.  
  430.            { Frame date with Shadow }
  431.            Canvas.Pen.Color := clGray;
  432.            Canvas.MoveTo( TempRect.Left, TempRect.Bottom - 1 );
  433.            Canvas.LineTo( TempRect.Left, TempRect.Top );
  434.            Canvas.LineTo( TempRect.Right - 1, TempRect.Top );
  435.  
  436.            { Frame date with Highlight }
  437.            Canvas.Pen.Color := clWhite;
  438.            Canvas.LineTo( TempRect.Right - 1, TempRect.Bottom - 1 );
  439.            Canvas.LineTo( TempRect.Left, TempRect.Bottom - 1 );
  440.  
  441.            { Restore Canvas settings}
  442.            Canvas.Pen.Color := clBlack;
  443.            Canvas.Font.Style := [];
  444.  
  445.         end;
  446.   StrDispose( pDate );
  447. end;
  448.  
  449. {********************* Form Cancel ************************
  450.  **********************************************************}
  451. procedure TfrmCalPop.FormCancel;
  452. begin
  453.   m_MouseDown := False;
  454.   ModalResult := -1;
  455. end;
  456.  
  457. {******************* Form Key Down ************************
  458.  **********************************************************}
  459. procedure TfrmCalPop.FormKeyDown(Sender: TObject; var Key: Word;
  460.   Shift: TShiftState);
  461. begin
  462.      Case key of
  463.           VK_Left : begin
  464.                         PrevDay;
  465.                         If (m_CurrentMonth <> m_PreviousMonth) or
  466.                            (m_CurrentYear <> m_PreviousYear) Then
  467.                            Refresh
  468.                         else
  469.                            DrawFocusFrame(m_CurrentDateIndex);
  470.                      end;
  471.           VK_Right : begin
  472.                         NextDay;
  473.  
  474.                         If (m_CurrentMonth <> m_PreviousMonth) or
  475.                            (m_CurrentYear <> m_PreviousYear) Then
  476.                            Refresh
  477.                         else
  478.                            DrawFocusFrame(m_CurrentDateIndex);
  479.                      end;
  480.           VK_Up : begin
  481.                         PrevWeek;
  482.                         If (m_CurrentMonth <> m_PreviousMonth) or
  483.                            (m_CurrentYear <> m_PreviousYear) Then
  484.                            Refresh
  485.                         else
  486.                            DrawFocusFrame(m_CurrentDateIndex);
  487.                      end;
  488.           VK_Down : begin
  489.                         NextWeek;
  490.                         If (m_CurrentMonth <> m_PreviousMonth) or
  491.                            (m_CurrentYear <> m_PreviousYear) Then
  492.                            Refresh
  493.                         else
  494.                            DrawFocusFrame(m_CurrentDateIndex);
  495.                      end;
  496.           VK_Prior: begin
  497.                         PrevMonth;
  498.                         Refresh;
  499.                      end;
  500.           Vk_Next : begin
  501.                         NextMonth;
  502.                         Refresh;
  503.                      end;
  504.  
  505.           VK_Home : begin
  506.                         NextYear;
  507.                         Refresh;
  508.                      end;
  509.           VK_End : begin
  510.                         PrevYear;
  511.                         Refresh;
  512.                      end;
  513.           VK_Return: begin
  514.                         TDateEdit( ctlParent ).Date := m_CurrentDateSelected;
  515.                         ModalResult := 1;
  516.                      end;
  517.           VK_Escape : FormCancel;
  518.      else
  519.  
  520.      end;
  521. end;
  522.  
  523.  
  524. {********************** Form Mouse Down *******************
  525.  **********************************************************}
  526. procedure TfrmCalPop.FormMouseDown(Sender: TObject; Button: TMouseButton;
  527.   Shift: TShiftState; X, Y: Integer);
  528. var
  529.   nIndex : Integer;
  530.   Key: Word;
  531. begin
  532.   {Check if mouse was pressed in Left button area}
  533.   if PointInRect(GetLeftButtonRect, X, Y) then
  534.      begin
  535.         Key := Vk_Prior;
  536.         FormKeyDown(Sender, Key,Shift);
  537.      end;
  538.  
  539.   {Check if mouse was pressed in Right button area}
  540.   if PointInRect(GetRightButtonRect, X, Y) then
  541.      begin
  542.         Key := Vk_Next;
  543.         FormKeyDown(Sender, Key,Shift);
  544.      end;
  545.  
  546.   {Check if mouse was pressed in date area}
  547.   if PointInRect(GetCalendarRect, X, Y) then
  548.      begin
  549.         m_MouseDown := True;
  550.         nIndex := GetIndexFromPoint( X, Y );
  551.  
  552.         If (nIndex >= GetMonthBegin) and
  553.            (nIndex < (DaysInMonth(m_CurrentMonth) + GetMonthBegin)) Then
  554.            begin
  555.              SetDate(nIndex - m_CurrentDateIndex);
  556.              DrawFocusFrame(nIndex);
  557.            end
  558.         else
  559.             m_MouseDown := False;
  560.  
  561.      end;
  562. end;
  563.  
  564. {******************* Form Mouse Move **********************
  565.  **********************************************************}
  566. procedure TfrmCalPop.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  567.   Y: Integer);
  568. var
  569.   nIndex : Integer;
  570. begin
  571.     If m_MouseDown = True then
  572.        begin
  573.           if PointInRect(GetCalendarRect, X, Y) then
  574.           begin
  575.                nIndex := GetIndexFromPoint( X, Y );
  576.                If (nIndex >= GetMonthBegin) and
  577.                   (nIndex < (DaysInMonth(m_CurrentMonth) + GetMonthBegin)) and
  578.                   (nIndex <> m_CurrentDateIndex) Then
  579.                begin
  580.                     SetDate(nIndex - m_CurrentDateIndex);
  581.                     DrawFocusFrame(nIndex);
  582.                end;
  583.           end;
  584.        end;
  585. end;
  586.  
  587.  
  588. {******************* Form Mouse Up ************************
  589.  **********************************************************}
  590. procedure TfrmCalPop.FormMouseUp( Sender: TObject; Button: TMouseButton;
  591.   Shift: TShiftState; X, Y: Integer );
  592. var
  593.    TempRect : Trect;
  594. begin
  595.   If m_MouseDown = True Then
  596.      begin
  597.         m_MouseDown := False;
  598.         TDateEdit( ctlParent ).Date := m_CurrentDateSelected;
  599.         ModalResult := 1;
  600.      end;
  601. end;
  602.  
  603.  
  604. {********************** Form Paint ************************
  605.  **********************************************************}
  606. procedure TfrmCalPop.FormPaint(Sender: TObject);
  607. begin
  608.   DrawCalendarBorder;
  609.   DrawMonthHeader;
  610.   DrawDaysHeader;
  611.   DrawDates;
  612.   DrawButtons;
  613.   DrawFocusFrame(m_CurrentDateIndex);
  614. end;
  615.  
  616.  
  617. {********************* Get Left Button Rectangle ******************
  618.  ***** Get the rectangle used for the left button.            *****
  619.  ******************************************************************}
  620. function TfrmCalPop.GetLeftButtonRect: TRect;
  621. var
  622.   TempRect: TRect;
  623. begin
  624.    {Define Left Button Rectangle}
  625.    TempRect.Top := ClientRect.Top + BORDER;
  626.    TempRect.Bottom := TempRect.Top + BUTTON_WIDTH;
  627.    TempRect.Left := ClientRect.Left + BORDER + TEXT_INDENT;
  628.    TempRect.Right := TempRect.Left + BUTTON_WIDTH;
  629.  
  630.    Result := TempRect;
  631. end;
  632.  
  633. {******************** Get Right Button Rectangle ******************
  634.  ***** Get the rectangle used for the right button.           *****
  635.  ******************************************************************}
  636. function TfrmCalPop.GetRightButtonRect: TRect;
  637. var
  638.   TempRect: TRect;
  639. begin
  640.    {Define Right Button Rectangle}
  641.    TempRect.Top := ClientRect.Top + BORDER;
  642.    TempRect.Bottom := TempRect.Top + BUTTON_WIDTH;
  643.    TempRect.Right := BORDER + TEXT_INDENT + (m_FontWidth * 3 * 7);
  644.    TempRect.Left := TempRect.Right - BUTTON_WIDTH;
  645.  
  646.    Result := TempRect;
  647. end;
  648.  
  649. {********************** Get Calendar Rectangle ********************
  650.  ***** Get the rectangle used for the calendar section        *****
  651.  ******************************************************************}
  652. function TfrmCalPop.GetCalendarRect: TRect;
  653. var
  654.   TempRect: TRect;
  655. begin
  656.   TempRect := ClientRect;
  657.  
  658.   with TempRect do
  659.      begin
  660.         Left := BORDER + TEXT_INDENT;
  661.         Top := ( m_FontHeight * 2 ) + BORDER;
  662.         Bottom := Top + ( m_FontHeight * 6 );
  663.         Right := Left + ( 7 * ( m_fontWidth * 3 ) );
  664.      end;
  665.  
  666.   Result := TempRect;
  667. end;
  668.  
  669.  
  670. {******************** Get Rectangle From Index ********************
  671.  ***** Get the rectangle used for the calendar section        *****
  672.  ******************************************************************}
  673. function TfrmCalPop.GetRectFromIndex(nIndex : Integer): TRect;
  674. var
  675.   TempRect: TRect;
  676.   nWeek : Integer;
  677.   nDay : Integer;
  678. begin
  679.   TempRect := GetCalendarRect;
  680.  
  681.   with TempRect do
  682.      begin
  683.         case nIndex of
  684.              1..7 :  nWeek := 1;
  685.              8..14:  nWeek := 2;
  686.              15..21: nWeek := 3;
  687.              22..28: nWeek := 4;
  688.              29..35: nWeek := 5;
  689.              36..42: nWeek := 6;
  690.         end;
  691.  
  692.         nDay := nIndex - ((nWeek-1) *7);
  693.  
  694.         Left := Left + ((m_FontWidth * 3) * (nDay-1));
  695.         Top := (m_FontHeight * nWeek ) + m_FontHeight + BORDER;
  696.         Bottom := Top +  m_FontHeight ;
  697.         Right := Left + m_fontWidth * 3;
  698.      end;
  699.  
  700.   Result := TempRect;
  701. end;
  702.  
  703. {*************************** Get Month Begin **************************
  704.  ***** This function Gets the index value of the first day of the *****
  705.  ***** month.                                                     *****
  706.  ********************************************************************** }
  707. function TfrmCalPop.GetMonthBegin: Integer;
  708. var
  709.   FirstDate: TDateTime;
  710. begin
  711.   FirstDate := EncodeDate( m_CurrentYear, m_CurrentMonth, 1 );
  712.   Result := DayOfWeek( FirstDate ); { day of week for 1st of month }
  713. end;
  714.  
  715.  
  716. {********************** Is Leap Year **********************
  717.  **********************************************************}
  718. function TfrmCalPop.IsLeapYear: Boolean;
  719. begin
  720.   Result := ( m_CurrentYear mod 4 = 0 ) and
  721.             ( ( m_CurrentYear mod 100 <> 0 ) or ( m_CurrentYear mod 400 = 0 ) );
  722. end;
  723.  
  724.  
  725. {********************** LoadDateArray *********************
  726.  **********************************************************}
  727. procedure TfrmCalPop.LoadDateArray;
  728. var
  729.   nIndex : Integer;
  730.   nBeginIndex, nEndIndex : Integer;
  731. begin
  732.   nBeginIndex := GetMonthBegin;
  733.   nEndIndex := nBeginIndex + DaysInMonth(m_CurrentMonth) - 1;
  734.   for nIndex := 1 to 42 do
  735.   begin
  736.      If ( nIndex < nBeginIndex ) or ( nIndex > nEndIndex ) Then
  737.         m_DateArray[nIndex] := '  '
  738.      else
  739.         m_DateArray[nIndex] := IntToStr( ( nIndex - nBeginIndex ) + 1 );
  740.   end;
  741. end;
  742.  
  743.  
  744. {******************** Get Index From Date *****************
  745.  **********************************************************}
  746. function TfrmCalPop.GetIndexFromDate : Integer;
  747. begin
  748.      Result := m_CurrentDay + GetMonthBegin;
  749. end;
  750.  
  751.  
  752. {****************** Get Index From Point ******************
  753.  **********************************************************}
  754. function TfrmCalPop.GetIndexFromPoint(nLeft : Integer ; nTop : Integer) : Integer;
  755. var
  756.   nIndex, nWeek, nDay: Integer;
  757.   nResult: Real;
  758.   TempRect: Trect;
  759. begin
  760.   TempRect := GetCalendarRect;
  761.  
  762.   nIndex := -1;
  763.   {Is point in the calendar rectangle?}
  764.   if ( nLeft > TempRect.Left ) and ( nTop > TempRect.Top ) and
  765.       ( nLeft < TempRect.Right ) and ( nTop < TempRect.Bottom ) then
  766.      begin
  767.  
  768.         { Determine the week number of the selected date }
  769.         nResult := ( nTop - BORDER ) / ( m_FontHeight ) - 1;
  770.         nWeek := Trunc( nResult );
  771.  
  772.         { Adjust Date Rect }
  773.         TempRect.Top := TempRect.Top + ( ( nWeek - 1 ) * m_FontHeight );
  774.         TempRect.Bottom := TempRect.Top + m_FontHeight;
  775.         TempRect.Left := BORDER + TEXT_INDENT;
  776.         TempRect.Right := TempRect.Left + m_FontWidth * 3;
  777.  
  778.         { Determine the day number of the selected date }
  779.         for nDay := 1 to 7 do        {Cycle through the days}
  780.            begin
  781.               nIndex := nDay + ( ( nWeek - 1 ) * 7 );
  782.               if ( nLeft >= TempRect.Left ) and ( nLeft <= TempRect.Right ) then
  783.                  break
  784.               else
  785.                  begin
  786.                     TempRect.Left := TempRect.Right;
  787.                     TempRect.Right := TempRect.Left + m_FontWidth * 3;
  788.                  end;
  789.            end;
  790.      end;
  791.   Result := nIndex;
  792. end;
  793.  
  794.  
  795. {******************** Get Previous Day ********************
  796.  **********************************************************}
  797. procedure TfrmCalPop.PrevDay;
  798. begin
  799.     SetDate(-1);
  800. end;
  801.  
  802.  
  803. {********************* Get Next Day ***********************
  804.  **********************************************************}
  805. procedure TfrmCalPop.NextDay;
  806. begin
  807.      SetDate(1);
  808. end;
  809.  
  810.  
  811. {******************** Get Previous Week *******************
  812.  **********************************************************}
  813. procedure TfrmCalPop.PrevWeek;
  814. begin
  815.     SetDate(-7);
  816. end;
  817.  
  818.  
  819. {******************** Get Next Week ***********************
  820.  **********************************************************}
  821. procedure TfrmCalPop.NextWeek;
  822. begin
  823.      SetDate(7);
  824. end;
  825.  
  826.  
  827. {******************** GetPreviousMonth ********************
  828.  **********************************************************}
  829. procedure TfrmCalPop.PrevMonth;
  830. var
  831.    nDays : Integer;
  832.    nMonth : Integer;
  833. begin
  834.   if m_CurrentMonth > 1 then
  835.      nMonth := m_CurrentMonth - 1
  836.   else
  837.      nMonth := 12;
  838.   nDays := DaysInMonth(nMonth);
  839.   SetDate(-nDays);
  840. end;
  841.  
  842.  
  843. {******************** Get Next Nonth **********************
  844.  **********************************************************}
  845. procedure TfrmCalPop.NextMonth;
  846. begin
  847.   SetDate(DaysInMonth(m_CurrentMonth));
  848. end;
  849.  
  850. {GetNextYear}
  851. procedure TfrmCalPop.NextYear;
  852. begin
  853.  
  854.   {If the current year is a leap year and the date is
  855.    before February 29, add 1 day}
  856.   If IsLeapYear and (m_CurrentMonth < 3) Then
  857.      SetDate(1);
  858.  
  859.   SetDate(365);
  860.   {If the current year is a leap year and the date is
  861.    after February 29, add 1 day}
  862.   If IsLeapYear and (m_CurrentMonth > 3) Then
  863.      SetDate(1);
  864. end;
  865.  
  866.  
  867. {******************* GetPrevious Year *********************
  868.  **********************************************************}
  869. procedure TfrmCalPop.PrevYear;
  870. begin
  871.   {If the current year is a leap year and the date is
  872.    after February 29, subtract 1 day}
  873.   If IsLeapYear and (m_CurrentMonth > 3) Then
  874.      SetDate(-1);
  875.  
  876.   SetDate(-365);
  877.   {If the Previous year is a leap year and the date is
  878.    before February 29, subtract 1 day}
  879.   If IsLeapYear and (m_CurrentMonth < 3) Then
  880.      SetDate(-1);
  881. end;
  882.  
  883.  
  884. {***************** Set Date **************************
  885.  **** This procedure adjusts the date by nDays    ****
  886.  **** nDays can be possitive or negative.  It     ****
  887.  **** also populates the vars YEAR, MONTH and DAY ****
  888.  *****************************************************}
  889. procedure TfrmCalPop.SetDate(nDays : Integer);
  890. begin
  891.    {Save current date information}
  892.    m_PreviousDateIndex := m_CurrentDateIndex;
  893.    DecodeDate(m_CurrentDateSelected,m_PreviousYear,m_PreviousMonth,m_PreviousDay);
  894.  
  895.    {Change the date and update member variables}
  896.    m_CurrentDateSelected := m_CurrentDateSelected + nDays;
  897.    DecodeDate(m_CurrentDateSelected,m_CurrentYear,m_CurrentMonth,m_CurrentDay);
  898.    m_CurrentDateIndex := ( m_CurrentDay + GetMonthBegin ) - 1;
  899.  
  900.    {Reload Date Array if month or year changed}
  901.    If (m_CurrentMonth <> m_PreviousMonth) or (m_CurrentYear <> m_PreviousYear)Then
  902.       LoadDateArray;
  903. end;
  904.  
  905. end.
  906.